home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel-075.lha / feel0.75 / Src / table.c < prev    next >
C/C++ Source or Header  |  1992-06-18  |  15KB  |  619 lines
  1. /* ******************************************************************** */
  2. /*  table.c          Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /*  "hash" tables                                                       */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: table.c,v 1.13 1992/05/19 11:27:25 pab Exp $
  9.  *
  10.  * $Log: table.c,v $
  11.  * Revision 1.13  1992/05/19  11:27:25  pab
  12.  * fixed for daft compilers
  13.  *
  14.  * Revision 1.12  1992/04/27  22:01:02  pab
  15.  * fixed stackers
  16.  *
  17.  * Revision 1.11  1992/04/21  19:53:24  pab
  18.  * Fixed traverse_table, assuming TCOMPARE allocates.
  19.  *
  20.  * Revision 1.10  1992/01/29  13:50:50  pab
  21.  * vax fix
  22.  *
  23.  * Revision 1.9  1992/01/17  22:32:50  pab
  24.  * fixed hash problemette
  25.  *
  26.  * Revision 1.8  1992/01/10  15:16:24  pab
  27.  * macroised total_hash
  28.  *
  29.  * Revision 1.7  1992/01/09  22:29:09  pab
  30.  * Fixed for low tag ints
  31.  *
  32.  * Revision 1.6  1992/01/07  22:15:46  pab
  33.  * ncc compatable, plus backtrace
  34.  *
  35.  * Revision 1.5  1992/01/05  22:48:29  pab
  36.  * Minor bug fixes, plus BSD version
  37.  *
  38.  * Revision 1.4  1991/12/22  15:14:42  pab
  39.  * Xmas revision
  40.  *
  41.  * Revision 1.3  1991/09/22  19:14:42  pab
  42.  * Fixed obvious bugs
  43.  *
  44.  * Revision 1.2  1991/09/11  12:07:48  pab
  45.  * 11/9/91 First Alpha release of modified system
  46.  *
  47.  * Revision 1.1  1991/08/12  16:50:08  pab
  48.  * Initial revision
  49.  *
  50.  * Revision 1.4  1991/02/14  11:27:51  kjp
  51.  * Boosted table efficiency by inlining eq among other stuff.
  52.  *
  53.  */
  54.  
  55. #define KJPDBG(x) 
  56.  
  57. /*
  58.  * Change Log:
  59.  *   Version 1, April 1989
  60.  *        Syntax fixes - JPff
  61.  *        Name changes - RJB
  62.  *        Fixed the copy functions - KJP ( 17/10/89 )
  63.  *        Arbitrary lisp functions - KJP ( 27/9/90 )
  64.  */
  65.  
  66. /* "Tables provide a general key to value association mechanism.
  67.  *  Operationally, tables resemble hashtables, but the actual
  68.  *  representation is not defined in order to permit alternative
  69.  *  solutions, such as various forms of balanced trees."
  70.  
  71.  * (tablep obj) -> { t | nil }
  72.  * (make-table [comparator]) -> table                comparator is an "equal"
  73.  * (table-parameters table) -> multiple-value
  74.  * (tref table key) -> obj
  75.  * ((set tref) table key obj) -> nil
  76.  * (map-table table function) -> nil
  77.  */
  78.  
  79. /* How about: a "table" is a balanced tree of some sorts: use a VECTOR
  80.  * [key, value, hash, left, right]
  81.  * and use the hash to binary chop.
  82.  */
  83.  
  84. #include "funcalls.h"
  85. #include "defs.h"
  86. #include "structs.h"
  87. #include "error.h"
  88. #include "global.h"
  89. #include "modboot.h"
  90.  
  91. #include "ngenerics.h"
  92.  
  93. #include "calls.h"
  94.  
  95. #define TABLES_ENTRIES 11
  96. MODULE Module_tables;
  97. LispObject Module_tables_values[TABLES_ENTRIES];
  98.  
  99. #define TKEY(node)    vref((node),0)
  100. #define TVALUE(node)  vref((node),1)
  101. #define THASH(node)   intval(vref((node),2))
  102. #define TLEFT(node)   vref((node),3)
  103. #define TRIGHT(node)  vref((node),4)
  104.  
  105. #define total_hash(x) (is_symbol(x)? x->SYMBOL.hash: total_hash_fn(x))
  106.  
  107. /* Comparison with optimisation */
  108.  
  109. #define TCOMPARE(tab,k1,k2) \
  110.           (tab->comparator == Fn_eq \
  111.              ? k1 == k2 \
  112.          : (tab->comparator == NULL \
  113.           ? EUCALL_3(apply2,tab->lisp_comparator,k1,k2) != nil \
  114.           : EUCALL_2((*(tab->comparator)),k1,k2) != nil))
  115.  
  116. /* slow but fun hash from gdbm */
  117.  
  118. int
  119. hash (char *dptr)
  120. {
  121.   int  value;        /* Used to compute the hash value.  */
  122.   int  index;        /* Used to cycle through random values. */
  123.  
  124.  
  125.   /* Set the initial value from key. */
  126.   value = 0x238F13AF;
  127.   for (index = 0; index<10&&dptr[index]!='\0'; index++)
  128.     value = (value + (dptr[index] << (index*5 % 24))) & 0x7FFFFFFF;
  129.  
  130.   value = (1103515243 * value + 12345) & 0x7FFFFFFF;  
  131.  
  132.   /* Return the value. */
  133.   return value;
  134. }
  135.  
  136.  
  137. static int total_hash_fn(LispObject x)
  138. {
  139.   switch (typeof(x)) {
  140.   case TYPE_CLASS:
  141.     x=x->CLASS.name; /* and fall through */
  142.    case TYPE_SYMBOL:
  143.     return x->SYMBOL.hash;
  144.    case TYPE_INT:
  145.     return(intval(x));
  146.    case TYPE_FLOAT:
  147.     return((int) (x->FLOAT.fvalue));
  148.   }
  149.  
  150.   /* No dice - linear search */
  151.  
  152.   return(0); 
  153. }
  154.  
  155. EUFUN_1( Fn_tablep, x)
  156. {
  157.   if (is_table(x)) return lisptrue;
  158.   return nil;
  159. }
  160. EUFUN_CLOSE
  161.  
  162. extern LispObject Gf_equal(LispObject*);
  163.  
  164. EUFUN_1( Fn_make_table, forms)
  165. {
  166.   extern LispObject function_eq;
  167.   struct table_structure* new_table;
  168.  
  169.   if (forms == nil) 
  170.     new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  171.   else {
  172.     LispObject fn;
  173.  
  174.     fn = CAR(forms);
  175.  
  176.     if (fn == function_eq) 
  177.       new_table = &allocate_table(stacktop,Fn_eq)->TABLE;
  178.     else {
  179.       new_table = &allocate_table(stacktop,NULL)->TABLE;
  180.       new_table->lisp_comparator = CAR(ARG_0(stackbase));
  181.     }
  182.   }
  183.   
  184.   return((LispObject) new_table);
  185. }
  186. EUFUN_CLOSE
  187.  
  188. /* temporary while we work out multiple values */
  189. LispObject table_params_kludge;
  190.  
  191. void cons_up_table_params(LispObject *stacktop, LispObject table)
  192. {
  193.  top:
  194.   if (null(table)) return;
  195.   cons_up_table_params(stacktop,TLEFT(table));
  196.   EUCALLSET_2(table_params_kludge,Fn_cons, TVALUE(table), table_params_kludge);
  197.   table = TRIGHT(table);
  198.   goto top;
  199. }
  200.  
  201. extern void cons_up_table_keys(LispObject*,LispObject);
  202.  
  203. void cons_up_table_keys(LispObject *stacktop, LispObject table)
  204. {
  205.  top:
  206.   if (null(table)) return;
  207.   STACK_TMP(table);
  208.   cons_up_table_keys(stacktop,TLEFT(table));
  209.   UNSTACK_TMP(table);
  210.   STACK_TMP(table);
  211.   EUCALLSET_2(table_params_kludge,Fn_cons, TKEY(table), table_params_kludge);
  212.   UNSTACK_TMP(table);
  213.   table = TRIGHT(table);  
  214.   goto top;
  215. }
  216.  
  217. /* return a multiple value of all the values in the table */
  218. EUFUN_1( Fn_table_parameters, table)
  219. {
  220.   while (!is_table(table))
  221.     table = CallError(stacktop,"table-parameters: ~a is not a table", table,
  222.               CONTINUABLE);
  223.   table_params_kludge = nil;
  224.   cons_up_table_params(stacktop,table->TABLE.tree);
  225.   return table_params_kludge;
  226. }
  227. EUFUN_CLOSE
  228.  
  229. /* Usefull ?? */
  230. EUFUN_1( Fn_table_keys, table)
  231. {
  232.   if (table == nil) return(nil); /* HACK !! */
  233.   table_params_kludge = nil;
  234.   cons_up_table_keys(stacktop,table->TABLE.tree);
  235.   return table_params_kludge;
  236. }
  237. EUFUN_CLOSE
  238.  
  239. /* Look for key in table. Return nil if not found */
  240. static LispObject traverse_table(LispObject *stacktop, struct table_structure* table,
  241.               LispObject key)
  242. {
  243.   LispObject node = nil;
  244.   LispObject tab=(LispObject)table;
  245.   int hashval;
  246.  
  247.   hashval = total_hash(key);
  248.   node = table->tree;
  249.   do {
  250.     if (null(node)) {        /* end of tree - key not found */
  251.       return nil;
  252.     }
  253.     STACK_TMP(tab);
  254.     STACK_TMP(key);
  255.     STACK_TMP(node);
  256.     if (TCOMPARE((&(tab->TABLE)),TKEY(node),key)) {
  257.       UNSTACK_TMP(node);
  258.       return TVALUE(node);
  259.     }
  260.     UNSTACK_TMP(node);
  261.     UNSTACK_TMP(key);
  262.     UNSTACK_TMP(tab);
  263.     if (hashval < THASH(node)) node = TLEFT(node);
  264.     else node = TRIGHT(node);
  265.   } while (TRUE);
  266.  
  267.   return(nil);
  268. }
  269.  
  270. static LispObject traverse_eq_table(LispObject *stacktop, struct table_structure* table,
  271.                     LispObject key)
  272. {
  273.   LispObject node = nil;
  274.   int hashval;
  275.  
  276.   hashval = total_hash(key);
  277.   node = table->tree;
  278.   do {
  279.     if (null(node)) {        /* end of tree - key not found */
  280.       return nil;
  281.     }
  282.  
  283.     if (TKEY(node)==key) {
  284.       return TVALUE(node);
  285.     }
  286.     if (hashval < THASH(node)) node = TLEFT(node);
  287.     else node = TRIGHT(node);
  288.   } while (TRUE);
  289.  
  290.   return(nil);
  291. }
  292.  
  293. EUFUN_2( Fn_tref, table, key)
  294. {
  295.   LispObject ans;
  296.  
  297.   while (!is_table(table))
  298.     table = CallError(stacktop,"tref: ~a is not a table", table, CONTINUABLE);
  299.   if (table->TABLE.comparator == Fn_eq)
  300.     ans = traverse_eq_table(stacktop, (struct table_structure*) table, key);
  301.   else
  302.     ans = traverse_table(stacktop, (struct table_structure*)table, key);
  303.   return ans;
  304. }
  305. EUFUN_CLOSE
  306.  
  307. LispObject insert_tree(LispObject *stacktop,struct table_structure* table,
  308.                LispObject key, LispObject value)
  309. {
  310.   LispObject node = nil, prev = nil;
  311.   int hashval, direction = 0;
  312.  
  313.   hashval = total_hash(key);
  314.   node = table->tree;
  315.   STACK_TMPV(table);
  316.   STACK_TMP(prev);
  317.   do {
  318.     LispObject tmp;
  319.  
  320.     if (null(node))
  321.       {        /* new node */
  322.     STACK_TMP(value);  STACK_TMP(key);
  323.     node = (LispObject)allocate_vector(stacktop,5);
  324.     UNSTACK_TMP(key);  TKEY(node) = key;
  325.     UNSTACK_TMP(value); TVALUE(node) = value;
  326.     STACK_TMP(node);
  327.     tmp = allocate_integer(stacktop,hashval); /* room for int */
  328.     UNSTACK_TMP(node);
  329.     vref(node,2)=tmp;
  330.     TLEFT(node) = nil;
  331.     TRIGHT(node) = nil;
  332.     UNSTACK_TMP(prev);
  333.     if (prev == nil) 
  334.       {    /* new tree */
  335.         UNSTACK_TMP(tmp);
  336.         table= &tmp->TABLE;
  337.         table->tree = node;
  338.         return nil;
  339.       }
  340.     STACK_TMP(prev);
  341.     if (direction == 1)
  342.       {    /* should balance here */
  343.         TRIGHT(prev) = node;
  344.       }
  345.     else
  346.       {
  347.         TLEFT(prev) = node;
  348.       }
  349.     return nil;
  350.       }
  351.     if (hashval == THASH(node))
  352.       { 
  353.     STACK_TMP((LispObject)table);
  354.     STACK_TMP(key);
  355.     STACK_TMP(node);
  356.     STACK_TMP(value);
  357.     if (TCOMPARE(table,TKEY(node),key)) 
  358.       {
  359.         LispObject old;
  360.         UNSTACK_TMP(value);
  361.         UNSTACK_TMP(node);
  362.         old=TVALUE(node);    
  363.         TVALUE(node) = value;
  364.         return old;
  365.       }
  366.     UNSTACK_TMP(value);
  367.     UNSTACK_TMP(node);
  368.     UNSTACK_TMP(key);
  369.     UNSTACK_TMP(tmp);    
  370.     table=&(tmp->TABLE);
  371.       }
  372.     UNSTACK_TMP(prev);
  373.     prev = node;
  374.     STACK_TMP(prev);
  375.     if (hashval < THASH(node))
  376.       {
  377.     direction = -1;
  378.     node = TLEFT(node);
  379.       }
  380.     else 
  381.       {
  382.     direction = 1;
  383.     node = TRIGHT(node);
  384.       }
  385.   } while (TRUE);
  386.  
  387.   return(nil);
  388. }
  389.  
  390. EUFUN_3( tref_updator, table, key, value)
  391. {
  392.   LispObject old;
  393.  
  394.   KJPDBG(  fprintf( stderr, "\n'tref_updator' with table %lX ", table ) );
  395.   
  396.   while(!is_table(table))
  397.     table = CallError(stacktop,
  398.               "tref-updator: ~a is not a table", table, CONTINUABLE);
  399.   key = ARG_1(stackbase); value = ARG_2(stackbase);
  400.   old = insert_tree(stacktop, (struct table_structure*)table, key, value);
  401.  
  402.   return old;
  403. }
  404. EUFUN_CLOSE
  405.  
  406. EUFUN_2( map_table, node, proc)
  407. {
  408. /* proc was stacked by Fn_map_table, and node is accessible through
  409.  * the table. Thus this function should only be called from Fn_map_table.
  410.  */
  411.   if (!null(TLEFT(node)))
  412.     EUCALL_2(map_table,TLEFT(node), proc);
  413.   proc = ARG_1(stackbase);
  414.   node = ARG_0(stackbase);
  415.   EUCALL_3(apply2,proc,TKEY(node),TVALUE(node));
  416.   proc = ARG_1(stackbase);
  417.   node = ARG_0(stackbase);
  418.  
  419.   stacktop = stackbase;
  420.   if (!null(TRIGHT(node)))
  421.     EUCALL_2(map_table, TRIGHT(node), proc);
  422.   return nil;
  423. }
  424. EUFUN_CLOSE
  425.  
  426. EUFUN_2( Fn_map_table, proc, table)
  427. {
  428.   LispObject node = nil;
  429.  
  430.   while (!is_table(table))
  431.     table = CallError(stacktop,
  432.               "map-table: ~a is not a table", table, CONTINUABLE);
  433.   ARG_1(stackbase) = table;
  434.   proc = ARG_0(stackbase);
  435.   while (!is_function(proc))
  436.     proc = CallError(stacktop,
  437.              "map-table: ~a is not a function", proc, CONTINUABLE);
  438.   table = ARG_1(stackbase);
  439.   node = (table->TABLE).tree;
  440.   if (!null(node)) {
  441.     STACK_TMP(node);
  442.     EUCALL_3(apply2,ARG_0(stackbase)/*proc*/,TKEY(node),TVALUE(node));
  443.     UNSTACK_TMP(node);
  444.     STACK_TMP(node);
  445.     if (!null(TLEFT(node)))
  446.       EUCALL_2(map_table, TLEFT(node), ARG_0(stackbase)/*proc*/);
  447.     UNSTACK_TMP(node);
  448.     if (!null(TRIGHT(node)))
  449.       EUCALL_2(map_table, TRIGHT(node), ARG_0(stackbase)/*proc*/);
  450.   }
  451.   return nil;
  452. }
  453. EUFUN_CLOSE
  454.  
  455. void table_copy_aux(LispObject *stacktop, LispObject node, LispObject new)
  456. {
  457. /*  LispObject node; */
  458. /*  node = old->TABLE.tree; */
  459.   if (!null(node)) {
  460.     fprintf(stderr, "copying "); 
  461.     STACK_TMP(new);
  462.     STACK_TMP(node);
  463.     EUCALL_2(Fn_print, TKEY(node), NULL);
  464.     UNSTACK_TMP(node);
  465.     STACK_TMP(node);
  466.     EUCALL_2(Fn_print, TVALUE(node), NULL);
  467.     UNSTACK_TMP(node);
  468.     UNSTACK_TMP(new);
  469.     STACK_TMP(new);
  470.     STACK_TMP(node);
  471.     EUCALL_3(tref_updator, new, TKEY(node), TVALUE(node));
  472.     KJPDBG( fprintf( stderr, "Tref updated the new table\n" ) );
  473.     if (!null(TLEFT(node))) {
  474.       UNSTACK_TMP(node);
  475.       UNSTACK_TMP(new);
  476.       STACK_TMP(new);
  477.       STACK_TMP(node);
  478.       table_copy_aux(stacktop,TLEFT(node), new);
  479.       UNSTACK_TMP(node);
  480.       UNSTACK_TMP(new);
  481.       STACK_TMP(new);
  482.       STACK_TMP(node);
  483.     }
  484.     if (!null(TRIGHT(node))) {
  485.       UNSTACK_TMP(node);
  486.       UNSTACK_TMP(new);
  487.       table_copy_aux(stacktop,TRIGHT(node), new);
  488.     }
  489.   }
  490.   return;
  491. }
  492.  
  493. EUFUN_1( table_copy, table)
  494. {
  495.   LispObject ans;
  496.  
  497.   ans = (LispObject) allocate_table(stacktop,table->TABLE.comparator);
  498.   ans->TABLE.lisp_comparator = table->TABLE.lisp_comparator;
  499.  
  500.   table_copy_aux(stacktop,table->TABLE.tree, ans);
  501.  
  502.   return ans;
  503. }
  504. EUFUN_CLOSE
  505.  
  506. EUFUN_1( Fn_clear_table, table)
  507. {
  508.   while (!is_table(table))
  509.     table = CallError(stacktop,"clear-table: ~a is not a table", table,
  510.               CONTINUABLE);
  511.   table->TABLE.tree = nil;
  512.   return table;
  513. }
  514. EUFUN_CLOSE
  515.  
  516. /* This function is not used by anyone!!!
  517. void put_table(LispObject *stacktop, LispObject tab1, LispObject tab2 )
  518. {
  519.   if ( tab1 == nil )
  520.     return;
  521.   else
  522.     table_copy_aux(stacktop,tab1->TABLE.tree, tab2);
  523. }
  524. */
  525.  
  526. LispObject sym_table_copy;
  527.  
  528. /* Printing... */
  529.  
  530. EUFUN_2( Md_generic_prin_Table, tab, stream)
  531. {
  532.   extern LispObject Gf_generic_prin(LispObject*);
  533.  
  534.   if (!is_stream(stream))
  535.     CallError(stacktop,
  536.           "generic-prin: non-stream argument",stream,NONCONTINUABLE);
  537.  
  538.   /* We assume the table's what it claims to be... */
  539.  
  540.   if (tab->TABLE.comparator == NULL) {
  541.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  542.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  543.     stream = ARG_1(stackbase);
  544.     fprintf(stream->STREAM.handle,")");
  545.   }
  546.   else {
  547.     if (tab->TABLE.comparator == Fn_eq)
  548.       fprintf(stream->STREAM.handle,"#T(eq)");
  549.     else
  550.       fprintf(stream->STREAM.handle,"#T(equal)");
  551.   }
  552.  
  553.   return(tab);
  554. }
  555. EUFUN_CLOSE
  556.  
  557. /* Writing... */
  558.  
  559. EUFUN_2( Md_generic_write_Table, tab, stream)
  560. {
  561.   extern LispObject Gf_generic_prin(LispObject*);
  562.  
  563.   if (!is_stream(stream))
  564.     CallError(stacktop,
  565.           "generic-write: non-stream argument",stream,NONCONTINUABLE);
  566.  
  567.   /* We assume the table's what it claims to be... */
  568.  
  569.   if (tab->TABLE.comparator == NULL) {
  570.     fprintf(stream->STREAM.handle,"#T(comparator: ");
  571.     EUCALL_2(Gf_generic_prin,tab->TABLE.lisp_comparator,stream);
  572.     stream = ARG_1(stackbase);
  573.     fprintf(stream->STREAM.handle,")");
  574.   }
  575.   else {
  576.     if (tab->TABLE.comparator == Fn_eq)
  577.       fprintf(stream->STREAM.handle,"#T(eq)");
  578.     else
  579.       fprintf(stream->STREAM.handle,"#T(equal)");
  580.   }
  581.  
  582.   return(tab);
  583. }
  584. EUFUN_CLOSE
  585.  
  586. void initialise_tables(LispObject *stacktop)
  587. {
  588.   LispObject fun, upd;
  589.  
  590.   open_module(stacktop,
  591.           &Module_tables,
  592.           Module_tables_values,
  593.           "tables",
  594.           TABLES_ENTRIES);
  595.  
  596.   (void) make_module_function(stacktop,"tablep",Fn_tablep,1);
  597.   (void) make_module_function(stacktop,"make-table",Fn_make_table,-1);
  598.   (void) make_module_function(stacktop,"table-parameters",Fn_table_parameters,1);
  599.   fun = make_module_function(stacktop,"table-ref",Fn_tref,2);
  600.   STACK_TMP(fun);
  601.   upd = make_unexported_module_function(stacktop,"table-ref-updator", tref_updator, 3);
  602.   UNSTACK_TMP(fun);
  603.   set_anon_associate(stacktop,fun, upd);
  604.  
  605.   (void) make_module_function(stacktop,"map-table",Fn_map_table,2);
  606.   sym_table_copy = make_module_function(stacktop,"copy-table", table_copy, 1);
  607.   add_root(&sym_table_copy);
  608.   sym_table_copy = sym_table_copy->SYMBOL.lvalue;
  609.   add_root(&sym_table_copy);
  610.  
  611.   (void) make_module_function(stacktop,"table-keys",Fn_table_keys,1);
  612.   (void) make_module_function(stacktop,"clear-table",Fn_clear_table,1);
  613.  
  614.   make_module_function(stacktop,"generic_generic_prin,Table",Md_generic_prin_Table,2);
  615.   make_module_function(stacktop,"generic_generic_write,Table",Md_generic_write_Table,2);
  616.   
  617.   close_module();
  618. }
  619.